home *** CD-ROM | disk | FTP | other *** search
/ Merciful 5 / Merciful - Disc 5.iso / software / p / pcqpascalv1.2d.lha / Examples2 / Scroller / Scroller.p
Text File  |  1997-05-06  |  4KB  |  143 lines
  1. Program Scroll;
  2.  
  3. { Scroller V1.0 © 1994 by Andreas Tetzl
  4.  
  5.   Dieses Programm ist Freeware.
  6.   Sie können es verwenden, solange mein Name erwähnt wird.
  7.  
  8.   Andreas Tetzl
  9.   Liebethaler Str.18
  10.   01796 Pirna
  11.   Tel. 03501/523854
  12. }
  13.  
  14. {$I "Include:Intuition/Intuition.i"}
  15. {$I "Include:Graphics/Graphics.i"}
  16. {$I "Include:Exec/Libraries.i"}
  17. {$I "Include:Graphics/Pens.i"}
  18. {$I "Include:Graphics/Text.i"}
  19. {$I "Include:Graphics/Blitter.i"}
  20. {$I "Include:Graphics/View.i"}
  21. {$I "Include:Utils/StringLib.i"}
  22. {$I "Include:Libraries/DOS.i"}
  23.  
  24. CONST
  25.   BMWIDTH = 640;          { Der zu scrollende Bereich sollte so klein wie möglich sein,
  26.                           { daß geht noch schneller. }
  27.   BMHEIGHT = 490+200;     { Zeilen*10+Höhe des Screens }
  28.  
  29.   Topaz : TextAttr = ("topaz.font",8,FS_NORMAL,FPB_ROMFONT);
  30.  
  31.   ns : NewScreen = (0,0,640,200,1,0,1,HIRES,CUSTOMSCREEN_f,NIL,NIL,NIL,NIL);
  32.   nw : NewWindow = (0,0,640,200,0,1,0,BORDERLESS+ACTIVATE+RMBTRAP,
  33.                     NIL,NIL,NIL,NIL,NIL,0,0,0,0,CUSTOMSCREEN_F);
  34.  
  35.   MyText : Array[1..49] of String =(
  36.    "","","","","","","","","","","","","","","","","","","","","","","",
  37.    "Scroller V1.0 © 1994 by Andreas Tetzl","","","","",
  38.    "Dieser Scroller benutzt die Blitterbefehle der",
  39.    "Graphics.Library.",
  40.    "Der Text wird in eine große Bitmap geschrieben,",
  41.    "und dann in die Bitmap des Screen geblittet.",
  42.    "Es ist auch möglich Grafik zu scrollen, aber",
  43.    "bei mehr Farben fängt's an zu ruckeln.",
  44.    "","","","","",
  45.    "Grüße gehen an","","",
  46.    "Diesel",
  47.    "und",
  48.    "Andreas Neumann",
  49.    "","","","");
  50.  
  51.  
  52.   Colors : Array[1..2] of Short = ($0,$FFF);       { Schwarz, Weiß }
  53.  
  54.  
  55. VAR Scr : ScreenPtr;
  56.     Win : WindowPtr;
  57.     RP, RP2 : RastPortPtr;
  58.     BM, BM2 : BitMapPtr;
  59.     VP : ViewPortPtr;
  60.     i, BitPlanes: Integer;
  61.     TopazFont : TextFontPtr;
  62.  
  63. PROCEDURE CleanExit(Why : String; RC : Integer);
  64. BEGIN
  65.  IF BM2^.Planes[0]<>NIL THEN FreeRaster(BM2^.Planes[0],BMWIDTH,BMHEIGHT);
  66.  IF Win<>NIL THEN CloseWindow(Win);
  67.  IF Scr<>NIL THEN CloseScreen(Scr);
  68.  IF TopazFont<>NIL THEN CloseFont(TopazFont);
  69.  IF GfxBase<>NIL THEN CloseLibrary(GfxBase);
  70.  IF Why<>NIL THEN Writeln(Why);
  71.  Exit(RC);
  72. END;
  73.  
  74. Function LeftMouseButton: Boolean;
  75. Type
  76.         bt = ^Byte;
  77. Var
  78.         bfe : bt;
  79. Begin
  80.         bfe := Address($bfe001);
  81.  
  82.         If (bfe^ MOD 128) > 64                  { bit 6 gesetzt ? }
  83.         then  LeftMouseButton := False          { ja -> nicht gedrückt }
  84.         else  LeftMouseButton := True;          { nein -> lmb gedrückt }
  85. end;
  86.  
  87. BEGIN
  88.  GfxBase:=OpenLibrary("graphics.library",0);
  89.  IF GfxBase=NIL THEN CleanExit("Kann Gfx.lib nicht öffnen",10);
  90.  Scr:=OpenScreen(adr(ns));
  91.  IF Scr=NIL THEN CleanExit("Kann Screen nicht öffnen",10);
  92.  VP:=adr(Scr^.SViewPort);
  93.  LoadRGB4(VP,adr(Colors),2);
  94.  nw.Screen:=Scr;
  95.  Win:=OpenWindow(adr(nw));
  96.  IF WIn=NIL THEN CleanExit("Kann Window nicht öffnen",10);
  97.  BM:=adr(Scr^.SBitMap);
  98.  RP:=adr(Scr^.SRastPort);
  99.  
  100.  TopazFont:=OpenFont(adr(Topaz));
  101.  IF TopazFont=NIL THEN CleanExit("Kann Topaz.Font nicht öffnen",10);
  102.  
  103.  New(BM2);
  104.  InitBitMap(BM2,1,BMWIDTH,BMHEIGHT);
  105.  BM2^.Planes[0]:=AllocRaster(BMWIDTH,BMHEIGHT);
  106.  IF BM2^.Planes[0]=NIL THEN CleanExit("Nicht genug Speicher für Bitmap",10);
  107.  
  108.  New(RP2);
  109.  InitRastPort(RP2);
  110.  RP2^.BitMap := BM2;
  111.  
  112.  SetFont(RP2,TopazFont);
  113.  SetRast(RP2,0);
  114.  
  115.  { Text in Bitmap schreiben }
  116.  For i:=1 to 49 do
  117.   BEGIN
  118.    Move(RP2,(BMWidth/2)-(TextLength(RP2,MyText[i],StrLen(MyText[i]))/2),i*10);
  119.    GText(RP2,MyText[i],StrLen(MyText[i]));
  120.   END;
  121.  
  122.  { Scrollen }
  123.  REPEAT
  124.   For i:=1 to BMHEIGHT-200 do
  125.    BEGIN
  126.     BitPlanes:=BltBitMap(BM2,0,i,BM,0,0,BMWIDTH,Scr^.Height,$C0,%00000001,NIL);
  127.     { Versuchen Sie mal einen sehr kleinen Bereich zu scrollen (z.B. 100*100) }
  128.  
  129.     IF LeftmouseButton THEN CleanExit(NIL,0);
  130.     { Wenn das Scrolling zu schnell ist, dann müssen Sie hier
  131.       warten. Delay(1) dauert zu lange, benutzen Sie WaitTimer() aus
  132.       Include:Utils/TimerUtils (Demo in Examples/TimerTest.p) }
  133.    END;
  134.  UNTIL FALSE;
  135. END.
  136.  
  137.  
  138.  
  139.  
  140.  
  141.  
  142.  
  143.